home *** CD-ROM | disk | FTP | other *** search
/ HPAVC / HPAVC CD-ROM.iso / pc / PASPHONG.ZIP / PASPHONG.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1996-06-13  |  12.3 KB  |  322 lines
  1. {
  2. Ok, here it is. A freeware 100% pascal phongshading program. No extra units
  3. are required. Just extract the program, and run it. I wrote it in bp 7, but I
  4. assume it will work in lower versions as well.A few remarks: 
  5. 1) The 'phong-map' is pretty crappy, so it looks a bit like gouraudshading
  6.    (Trust me, it's not :-).
  7. 2) Don't tell me it's slow, I know that (My latest routines are 6 times
  8.    faster).
  9. 3) Feel free to use it anywhere you want, and spread it if you want.
  10. 4) Comments are appreciated, as long as they are positive :-).
  11.  
  12. I wrote this version exclusively for this purpose, and removing the need for
  13. extra units or external files wasn't easy (Look at CreateTorusData, it was a
  14. real pain in the ...). I might post another program in the future calculate
  15. phong-maps using the complete phong-model, which looks a zillion times better.
  16. But don't count on it. Just an idea: You can try to use the texture-map
  17. routine from gfxfx2 to speed it up. I haven't tried it, but it should be
  18. possible. Last words: Have fun.
  19.  
  20. >--->---Cut here--->--->
  21.  
  22. {Freeware phong-shading routine. Spread it if you want. Credit me if you
  23. use it. Made by Jeroen Bouwens, The Netherlands.
  24. Mail me:
  25.  
  26. e-mail : j.bouwens@tn.ft.hse.nl (Preferred)
  27. Fido   : 2:284/123.3
  28.  
  29. Greets: Alex,Rob,Martijn,Maarten,Bas,Sean,Richard,Marcel,Jurjen,Michel,
  30.         Sonja,N-Faktor and all the other people I met at Wired (Cool party)}
  31.  
  32. Uses Crt;{$R- $Q-}
  33.  
  34. Var Faces                                : Array [1..320,1..3] Of Integer;
  35.     FNX,FNY,FNZ,Pind,PolyZ               : Array [1..320] Of Integer;
  36.     BX,BY,BZ,UT,VT,X,Y,Z,NX,NY,NZ        : Array [1..160] of Integer;
  37.     Cosinus,Sinus                        : Array [0..255] of LongInt;
  38.     Pict,Screen2                         : Pointer;
  39.     NumOfVerts,NumOfFaces,EyeDist,VirSeg : Word;
  40.     I,J,G,NumVisible,XT1,YT1,ZT1         : Integer;
  41.     Alpha,Beta,Gamma,K                   : Byte;
  42.     {Timer variables}Time                : Longint ABSOLUTE $0040:$006C;
  43.     T1,Aantal                            : LongInt;
  44.  
  45. {------Procedures that are not time-critical (Not used during rotation)------}
  46.  
  47. Procedure Palette(ColNum,R,G,B:Byte); Assembler;
  48. Asm Mov dx,$3c8; Mov al,ColNum; Out dx,al; Inc dx; Mov al,R;
  49.     Out dx,al; Mov al,G; Out dx,al; Mov al,B; Out dx,al End;
  50.  
  51. Procedure CalcVertexNormals;
  52. {Calculate the average normal vector at each vertex-point}
  53. Var I,J,NF                                 : Integer;
  54.     RelX1,RelY1,RelZ1,RelX2,RelY2,RelZ2,VL : Real;
  55. Begin
  56.   {In which face is each point used, and average these face-normals}
  57.   For I:=1 To NumOfVerts Do Begin
  58.     RelX1:=0; RelY1:=0; RelZ1:=0; NF:=0;
  59.     For J:=1 To NumOfFaces Do Begin
  60.       If (Faces[J,1]=I) Or (Faces[J,2]=I) Or (Faces[J,3]=I) Then Begin
  61.         RelX1:=RelX1+FNX[J]; RelY1:=RelY1+FNY[J]; RelZ1:=RelZ1+FNZ[J];
  62.         Inc(NF);
  63.       End;
  64.     End;
  65.     If NF<>0 then Begin
  66.       RelX1:=RelX1/NF; RelY1:=RelY1/NF; RelZ1:=RelZ1/NF;
  67.       VL:=Sqrt(RelX1*RelX1+RelY1*RelY1+RelZ1*RelZ1);
  68.       NX[I]:=Round((RelX1/VL)*120); NY[I]:=Round((RelY1/VL)*120);
  69.       NZ[I]:=Round((RelZ1/VL)*120);
  70.     End;
  71.   End;
  72. End;{CalcVertexNormals}
  73.  
  74. Procedure CreateTorusData;
  75. Var HorAngle,VertAngle,Count       : Integer;
  76.     CX,CY,RX1,RY1,RZ1,RX2,RY2,RZ2  : Real;
  77. Begin
  78.  
  79.   NumOfVerts:=160; NumOfFaces:=320; Count:=1;
  80.   For HorAngle:=0 To 15 Do Begin{Calculate vertex-positions}
  81.     CX:=Cos(HorAngle/2.546479089)*170;
  82.     CY:=Sin(HorAngle/2.546479089)*170;
  83.     For VertAngle:=0 To 9 Do Begin
  84.       X[Count]:=Round(CX+Cos(VertAngle/1.592)*Cos(HorAngle/2.546)*90);
  85.       Y[Count]:=Round(CY+Cos(VertAngle/1.592)*Sin(HorAngle/2.546)*90);
  86.       Z[Count]:=Round(Sin(VertAngle/1.59154931)*90);
  87.       Inc(Count);
  88.     End;
  89.   End;
  90.  
  91.   Count:=1;
  92.   For HorAngle:=0 To 15 Do{Store face-data (Which veticies form which face}
  93.     For VertAngle:=0 To 9 Do Begin
  94.       Faces[Count,3]:=HorAngle*10+VertAngle+1;
  95.       Faces[Count,2]:=HorAngle*10+(VertAngle+1) Mod 10+1;
  96.       Faces[Count,1]:=(HorAngle*10+VertAngle+10) Mod 160+1;
  97.       Inc(Count);
  98.       Faces[Count,3]:=HorAngle*10+(VertAngle+1) Mod 10+1;
  99.       Faces[Count,2]:=(HorAngle*10+(VertAngle+1) Mod 10+10) Mod 160+1;
  100.       Faces[Count,1]:=(HorAngle*10+VertAngle+10) Mod 160+1;
  101.       Inc(Count);
  102.     End;
  103.  
  104.   For Count:=1 To 320 Do Begin{Calculate and store face-normals}
  105.     RX1:=X[Faces[Count,2]]-X[Faces[Count,1]];
  106.     RY1:=Y[Faces[Count,2]]-Y[Faces[Count,1]];
  107.     RZ1:=Z[Faces[Count,2]]-Z[Faces[Count,1]];
  108.     RX2:=X[Faces[Count,3]]-X[Faces[Count,1]];
  109.     RY2:=Y[Faces[Count,3]]-Y[Faces[Count,1]];
  110.     RZ2:=Z[Faces[Count,3]]-Z[Faces[Count,1]];
  111.     FNX[Count]:=Round(RY1*RZ2-RY2*RZ1);
  112.     FNY[Count]:=Round(RZ1*RX2-RZ2*RX1);
  113.     FNZ[Count]:=Round(RX1*RY2-RX2*RY1);
  114.   End;
  115. End;{CreateTorusData}
  116.  
  117. Procedure Initialize;
  118. Begin
  119.  
  120.   Asm Mov ax,$13; Int $10 End;
  121.   GetMem(Screen2,64000);
  122.   VirSeg:=Seg(Screen2^);
  123.  
  124.   CreateTorusData;
  125.   CalcVertexNormals;
  126.  
  127.   For I:=0 To 255 Do Begin
  128.     Cosinus[I]:=Round(Cos(I/40.585707465)*128);
  129.     Sinus[I]:=Round(Sin(I/40.585707465)*128);
  130.   End;
  131.  
  132.   GetMem(Pict,65535);
  133.   {Palette-creation. Skip this one to see the non-lineair colour transition}
  134.   For I:=1 To 63 Do Palette(I,I,10+Round(I/1.4),20+Round(I/1.6));
  135.   {Here, the 'phong-map' as I call it is created. Normally I use a different
  136.    routine for that (Looks WAY better), but that one is too big}
  137.   For I:=0 To 255 Do For J:=0 To 255 Do Begin
  138.     Mem[Seg(Pict^):Ofs(Pict^)+Word(256*I)+J]:=
  139.         Round(Sqr(Sqr(Sin(I/81.487)))*Sqr(Sqr(Sin(J/81.487)))*62)+1;
  140.     {Just to show you how it looks:   }
  141.     Mem[$A000:320*Round(I/1.25)+J]:=Mem[Seg(Pict^):Ofs(Pict^)+Word(256*I)+J];
  142.   End;
  143.  
  144. End;{Initialize}
  145.  
  146. {----------Procedures that are time-critical (Used during rotation)----------}
  147. Procedure SwapScreen; Assembler;
  148. Asm Mov dx,$3DA; @@WaitVBL: In al,dx; and al,8; jz @@WaitVBL; Push ds;
  149.     Lds  si,Screen2; Mov  ax,$A000; Mov  es,ax; Xor  di,di;  Mov  cx,16000;
  150.     db $66; Rep  Movsw; Pop  ds End;
  151.  
  152. Procedure Cls(Var Where); Assembler;
  153. Asm Les di,Where; Mov cx,16000; db $66; Xor ax,ax; db $66; Rep Stosw; End;
  154.  
  155. Procedure Quicksort(Hi : Integer);
  156. Procedure Sort(L,R : Integer);
  157. Var I,J,X,Y : Integer;
  158. Begin
  159.   I:=L; J:=R; X:=PolyZ[(L+R) Div 2];
  160.   Repeat
  161.     While polyz[i]>x do inc(i); While x>polyz[j] do dec(j);
  162.     If I<=J Then Begin
  163.       Y:=PolyZ[I]; PolyZ[I]:=PolyZ[J]; PolyZ[J]:=Y;
  164.       Y:=Pind[I]; Pind[I]:=Pind[J]; Pind[J]:=Y;
  165.       Inc(I); Dec(J);
  166.     End;
  167.   Until I>J;
  168.   If L<J Then Sort(L,J); If I<R Then Sort(I,R);
  169. End;
  170. Begin Sort(1,Hi) End;{QuickSort}
  171.  
  172. Procedure NewTex(X1,Y1,U1,V1,X2,Y2,U2,V2,X3,Y3,U3,V3:Integer;Texture:Pointer);
  173. {The actual texture-map routine. Only a little commented :-}
  174. Var TexOfs                                       : Array [0..320] Of Word;
  175.     SO,Long                                      : Word;
  176.     XL,UL,VL,XR,UR,VR                            : Array [0..200] Of LongInt;
  177.     DY21,DY31,DY32,DX21,DX31,DX32,DU21,DU31,DU32 : LongInt;
  178.     DV21,DV31,DV32,U,V,I,J,K                     : LongInt;
  179. Begin
  180.  
  181.   {Sort for increasing y-coordinates}
  182.   For I:=1 To 2 Do Begin
  183.     If Y3<Y2 Then Begin
  184.       J:=Y3; Y3:=Y2; Y2:=J; J:=X3; X3:=X2; X2:=J;
  185.       J:=U3; U3:=U2; U2:=J; J:=V3; V3:=V2; V2:=J; End;
  186.     If Y2<Y1 Then Begin
  187.       J:=Y1; Y1:=Y2; Y2:=J; J:=X1; X1:=X2; X2:=J;
  188.       J:=U1; U1:=U2; U2:=J; J:=V1; V1:=V2; V2:=J; End;
  189.     If Y3<Y1 Then Begin
  190.       J:=Y1; Y1:=Y3; Y3:=J; J:=X1; X1:=X3; X3:=J;
  191.       J:=U1; U1:=U3; U3:=J; J:=V1; V1:=V3; V3:=J End
  192.   End;
  193.  
  194.   {Exception occurs when there are two top y-coords with the same value}
  195.   If (Y1=Y2) And (X1>X2) Then Begin
  196.     J:=X1; X1:=X2; X2:=J; J:=U1; U1:=U2; U2:=J; J:=V1; V1:=V2; V2:=J End;
  197.  
  198.   {Calculate X,U and V along the edges and store these}
  199. DY21:=Y2-Y1; DY31:=Y3-Y1; DY32:=Y3-Y2; DX21:=X2-X1; DX31:=X3-X1; DX32:=X3-X2;
  200. DU21:=U2-U1; DU31:=U3-U1; DU32:=U3-U2; DV21:=V2-V1; DV31:=V3-V1; DV32:=V3-V2;
  201.   XL[0]:=X1; XL[0]:=XL[0]*256; UL[0]:=U1;
  202.   UL[0]:=UL[0]*256; VL[0]:=V1; VL[0]:=VL[0]*256;
  203.   If Y1=Y2 Then Begin
  204.     XR[0]:=X2; XR[0]:=XR[0]*256; UR[0]:=U2; UR[0]:=UR[0]*256;
  205.     VR[0]:=V2; VR[0]:=VR[0]*256 End Else Begin
  206.     XR[0]:=XL[0]; UR[0]:=UL[0]; VR[0]:=VL[0]; End;
  207.   For I:=Y1+1 To Y2 Do Begin
  208.     XL[I-Y1]:=XL[I-Y1-1]+(DX31*256) Div DY31;
  209.     XR[I-Y1]:=XR[I-Y1-1]+(DX21*256) Div DY21;
  210.     UL[I-Y1]:=UL[I-Y1-1]+(DU31*256) Div DY31;
  211.     UR[I-Y1]:=UR[I-Y1-1]+(DU21*256) Div DY21;
  212.     VL[I-Y1]:=VL[I-Y1-1]+(DV31*256) Div DY31;
  213.     VR[I-Y1]:=VR[I-Y1-1]+(DV21*256) Div DY21;
  214.   End;
  215.   For I:=Y2+1 To Y3 Do Begin
  216.     XL[I-Y1]:=XL[I-Y1-1]+(DX31*256) Div DY31;
  217.     XR[I-Y1]:=XR[I-Y1-1]+(DX32*256) Div DY32;
  218.     UL[I-Y1]:=UL[I-Y1-1]+(DU31*256) Div DY31;
  219.     UR[I-Y1]:=UR[I-Y1-1]+(DU32*256) Div DY32;
  220.     VL[I-Y1]:=VL[I-Y1-1]+(DV31*256) Div DY31;
  221.     VR[I-Y1]:=VR[I-Y1-1]+(DV32*256) Div DY32;
  222.   End;
  223.  
  224.   {Calculate texture-offsets for longest horizontal line (at Y=Y2)}
  225.   Long:=Y2-Y1;
  226.   If XL[Long]<XR[Long] Then Begin
  227.     U:=UL[Long]; V:=VL[Long]; SO:=256*(V Shr 8)+(U Shr 8);
  228.     For I:=0 To XR[Long] Shr 8-XL[Long] Shr 8 Do Begin
  229.       TexOfs[I]:=256*(V Shr 8)+(U Shr 8)-SO;
  230.       U:=U+((UR[Long]-UL[Long])*256) Div (XR[Long]-XL[Long]+1);
  231.       V:=V+((VR[Long]-VL[Long])*256) Div (XR[Long]-XL[Long]+1);
  232.     End;
  233.   End Else Begin
  234.     U:=UR[Long]; V:=VR[Long]; SO:=256*(V Shr 8)+(U Shr 8);
  235.     For I:=0 To XL[Long] Shr 8-XR[Long] Shr 8 Do Begin
  236.       TexOfs[I]:=256*(V Shr 8)+(U Shr 8)-SO;
  237.       U:=U+((UL[Long]-UR[Long])*256) Div (XL[Long]-XR[Long]+1);
  238.       V:=V+((VL[Long]-VR[Long])*256) Div (XL[Long]-XR[Long]+1);
  239.     End;
  240.   End;
  241.  
  242.   {Fill polygon (=Read back X,U and V-coordinates from buffer) }
  243.   If XL[Long]<XR[Long] Then
  244.     For I:=0 To Y3-Y1 Do Begin
  245.       SO:=256*(VL[I] Shr 8)+(UL[I] Shr 8);
  246.       For J:=XL[I] Shr 8 To XR[I] Shr 8 Do
  247.         Mem[VirSeg:320*(I+Y1)+J]:=Mem[Seg(Texture^):Ofs(Texture^)+SO+
  248.                                       TexOfs[J-XL[I] Shr 8]]
  249.     End
  250.   Else
  251.     For I:=0 To Y3-Y1 Do Begin
  252.       SO:=256*(VR[I] Shr 8)+(UR[I] Shr 8);
  253.       For J:=XR[I] Shr 8 To XL[I] Shr 8 Do
  254.         Mem[VirSeg:320*(I+Y1)+J]:=Mem[Seg(Texture^):Ofs(Texture^)+SO+
  255.                                       TexOfs[J-XR[I] Shr 8]]
  256.     End;
  257. End;{NewTex}
  258.  
  259. Procedure Rotate(Var X,Y,Z:Integer;Alpha,Beta,Gamma:Byte);
  260. Var X2,X3,Y1,Y3,Z1,Z2 : Integer;
  261. Begin
  262.   Y1:=(Cosinus[Alpha]*Y-Sinus[Alpha]*Z) Div 128;
  263.   Z1:=(Sinus[Alpha]*Y+Cosinus[Alpha]*Z) Div 128;
  264.   X2:=(Cosinus[Beta]*X+Sinus[Beta]*Z1) Div 128;
  265.   Z:=(Cosinus[Beta]*Z1-Sinus[Beta]*X) Div 128;
  266.   X:=(Cosinus[Gamma]*X2-Sinus[Gamma]*Y1) Div 128;
  267.   Y:=(Sinus[Gamma]*X2+Cosinus[Gamma]*Y1) Div 128;
  268. End;{Rotate}
  269.  
  270. {--------------------------Main program-------------------------------------}
  271.  
  272. Begin
  273.  
  274.   Initialize; EyeDist:=150; Alpha:=0; Beta:=0; Gamma:=0;
  275.   Aantal:=0; T1:=Time;
  276.   Repeat
  277.     Cls(Screen2^);
  278.  
  279.     For I:=1 To NumOfVerts do Begin
  280.       {Rotate the vertex-coordinates}
  281.       XT1:=X[I]; YT1:=Y[I]; ZT1:=Z[I];
  282.       Rotate(XT1,YT1,ZT1,Alpha,Beta,Gamma);
  283.       Inc(ZT1,468);
  284.       BX[I]:=160+(XT1*EyeDist) Div ZT1;
  285.       BY[I]:=100+((YT1*EyeDist*83) Div 100) Div ZT1;
  286.       BZ[I]:=ZT1;
  287.       {Rotate vertex normals (Here's where the phong-shading is done}
  288.       XT1:=NX[I]; YT1:=NY[I]; ZT1:=NZ[I];
  289.       Rotate(XT1,YT1,ZT1,Alpha,Beta,Gamma);
  290.       UT[I]:=128+XT1; VT[I]:=128+YT1;
  291.     End;
  292.  
  293.     {Sort the polygons by z-value, so I know in which order to draw them}
  294.     NumVisible:=0;
  295.     For I:=1 to NumOfFaces Do
  296.       If (BX[Faces[I,3]]-BX[Faces[I,1]])*(BY[Faces[I,2]]-BY[Faces[I,1]])-
  297.       (BX[Faces[I,2]]-BX[Faces[I,1]])*(BY[Faces[I,3]]-BY[Faces[I,1]])>0 Then
  298.       Begin
  299.         Inc(NumVisible); Pind[NumVisible]:=I;
  300.         PolyZ[NumVisible]:=BZ[Faces[I,1]]+BZ[Faces[I,2]]+BZ[Faces[I,3]];
  301.       End;
  302.  
  303.     QuickSort(NumVisible);
  304.  
  305.     {Draw the object}
  306.     For I:=1 To NumVisible Do
  307.       NewTex(BX[Faces[Pind[I],1]],BY[Faces[Pind[I],1]],
  308.              UT[Faces[Pind[I],1]],VT[Faces[Pind[I],1]],
  309.              BX[Faces[Pind[I],2]],BY[Faces[Pind[I],2]],
  310.              UT[Faces[Pind[I],2]],VT[Faces[Pind[I],2]],
  311.              BX[Faces[Pind[I],3]],BY[Faces[Pind[I],3]],
  312.              UT[Faces[Pind[I],3]],VT[Faces[Pind[I],3]],Pict);
  313.  
  314.     Alpha:=(Alpha+2)Mod 256;Beta:=(Beta+255)Mod 256;Gamma:=(Gamma+1)Mod 256;
  315.     Inc(Aantal); SwapScreen;
  316.   Until KeyPressed;
  317.  
  318.   T1:=Time-T1; TextMode(LastMode);
  319.   WriteLn(Aantal/(T1/18.2) :1:2,' Frames per second');
  320.   ReadLn; Dispose(Pict);Dispose(Screen2);
  321. End.
  322.